home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops source / PPC source / cg-inst_ref < prev    next >
Text File  |  1998-04-20  |  18KB  |  752 lines
  1. marker m__cg-inst/ref
  2.  
  3. PPC?
  4. [IF]
  5. false    constant    debug?
  6. [ELSE]
  7. false    constant    debug?
  8. [THEN]
  9.  
  10. (*
  11. INSTRUCTION_CLASS is just used as a convenient way of compiling an
  12. instruction.  The fields can be set up individually, and we can print
  13. it when we compile it, etc.  We simplify the reg field terminology a
  14. bit, and just use rA and rB as the source regs, and rD as the destination.
  15. (This differs from the "real" definition of the logical ops which use rA
  16. as the destination, for some unfathomable reason.  But we kludge around
  17. that before generating the instruction.)
  18. *)
  19.  
  20. :class    INSTRUCTION_CLASS    super{ object }
  21. record
  22. {    ubyte    rA                ¥ 1st source
  23.     ubyte    rB                ¥ 2nd source
  24.     ubyte    rC                ¥ 3rd source (fmadd etc.)
  25.     ubyte    rD                ¥ destination
  26.     ubyte    inst_type
  27.     ubyte    primOp            ¥ primary opcode
  28.     uint    secOp            ¥ secondary opcode
  29.     ubyte    shift#
  30. public
  31.     ubyte    maskBegin
  32.     ubyte    maskEnd
  33.     bool    setCR?
  34.     bool    lit?
  35.     bool    update?            ¥ for load/stores: use update mode?
  36.     bool    complB?            ¥ for logicals: complement B operand - and -> andc etc.
  37.     bool    complResult?    ¥ for logicals: and -> nand etc.
  38.     bool    CR_op?            ¥ for logicals: condition reg op?
  39.     bool    use_CTR?        ¥ for branches: use count reg?
  40.     bool    use_cond?        ¥   use condition?
  41.     bool    branchOn1?        ¥   branch on CR bit 1 or 0?
  42.     bool    kludgeShiftCnt?    ¥ true if 6-bit shift cnt (which has to be split)
  43.     bool    shifted?        ¥ true if this is a shifted variant (addis etc.)
  44.     var        lit                ¥ allowing 32 bits 'cause we need 24 for branches
  45. }
  46.  
  47. :m >rA:            inline{ put: rA}        ;m
  48. :m >rB:            inline{ put: rB}        ;m
  49. :m >rC:            inline{ put: rC}        ;m
  50. :m >rD:            inline{ put: rD}        ;m
  51.  
  52. :m >lit:        inline{ put: lit  set: lit?}    ;m
  53. :m >primOp:        inline{ put: primOp}            ;m
  54. :m >secOp:        inline{ put: secOp}                ;m
  55. :m >type:        inline{ put: inst_type}            ;m
  56.  
  57. :m >shift:        put: shift#  shiftType  put: inst_type  ;m
  58. :m kludgeShiftCnt:    set: kludgeShiftCnt?  ;m
  59.  
  60. :m INVERT:        get: branchOn1? not  put: branchOn1?  ;m
  61.  
  62. private
  63. :m swapAB:    ¥ subtract, I think for historical reasons, is "subtract from"
  64.             ¥ and the operands are the other way around to the Forth convention.
  65.             ¥ Note this doesn't apply to floating point!
  66.     get: rA  get: rB  put: rA  put: rB
  67. ;m
  68.  
  69. public
  70. ¥ setop: maps our internal opcodes to the corresponding PPC instruction codes,
  71. ¥  and sets primOp, secOp and inst_type appropriately.
  72. ¥ Note fetches and stores have the PPC codes set directly from the OD class,
  73. ¥  and don't come here.
  74.  
  75. :m SETOP:  { opType subtype -- inst_type }
  76.  
  77.     clear: lit?
  78.     
  79.     opType
  80.     
  81.     SELECT[    otAdd    ]=>        arithType        31  266
  82.           [ otSub    ]=>        arithType        31  40    swapAB: self
  83.  
  84.           [    otAddc    ]=>        arithType        31  10
  85.           [    otAdde    ]=>        arithType        31  138
  86.           [    otAddze    ]=>        arithType        31  202
  87.           [    otAddme    ]=>        arithType        31  234
  88.  
  89.           [ otSubfc    ]=>        arithType        31    8     swapAB: self
  90.          [    otSubfe    ]=>        arithType        31    136  swapAB: self
  91.          [ otSubfze    ]=>        arithType        31    200     clear: rB
  92.          [ otSubfme    ]=>        arithType        31    232     clear: rB
  93.  
  94.           [    otMUL    ]=>        arithType          31
  95.                               64bit? if 233 else 235 then
  96.           
  97.           [ otMULH    ]=>        arithType        31
  98.                               64bit? if  73 else  75 then
  99.           
  100.           [    otUMULH    ]=>        arithType        31
  101.                               64bit? if   9 else  11 then
  102.  
  103.           [    otDIV    ]=>        arithType        31
  104.                               64bit? if 489 else 491 then
  105.  
  106.           [ otUDIV    ]=>        arithType        31
  107.                               64bit? if 457 else 459 then
  108.         
  109.  
  110.     ¥ floating point:
  111.     
  112.           [    otFADD    ]=>        arithType        63    21            ¥ fadd
  113.           [    otFSUB    ]=>        arithType        63    20            ¥ fsub
  114.           [    otFMUL    ]=>        arithType        63    25            ¥ fmul
  115.                                   ¥ fmuld uses the rC field as the second operand, like fmadd, which makes
  116.                                   ¥  sense to the hardware which treats it like an fmadd with an add of 0.
  117.                               get: rB  put: rC  clear: rB
  118.  
  119.           [    otFMADD    ]=>        arithType        63
  120.                               subtype
  121.                               SELECT[    0    ]=>        29            ¥ fmadd
  122.                                     [    1    ]=>        28            ¥ fmsub
  123.                                     [    2    ]=>        30            ¥ fnmsub
  124.                                     DEFAULT=>
  125.                                         cr .h ."  undef subtype for fmadd" 1 die
  126.                               ]SELECT
  127.                               get: rB  get: rC  put: rB  put: rC
  128.  
  129.  
  130.           [    otFDIV    ]=>        arithType        63    18            ¥ fdiv
  131.           
  132.     ¥ FP monadics - these use the rB field as the (single) source operand
  133.  
  134.           [    $ 54    ]=>        arithType        63    264            ¥ fabs
  135.                               get: rA  put: rB  clear: rA
  136.           [    $ 55    ]=>        arithType        63    40            ¥ fnegate
  137.                               get: rA  put: rB  clear: rA
  138.  
  139.  
  140.     ¥ logicals have a lot of options:
  141.  
  142.           [ otAnd    ]=>        logicalType
  143.                               get: CR_op? 
  144.                               IF    19  get: complResult?
  145.                                   IF         225                    ¥ crnand
  146.                                   ELSE    get: complB?
  147.                                           IF        129            ¥ crandc
  148.                                           ELSE    257            ¥ crand
  149.                                           THEN
  150.                                   THEN
  151.                             ELSE
  152.                                   31  get: complResult?
  153.                                   IF         476                    ¥ nand
  154.                                   ELSE    get: complB?
  155.                                           IF        60            ¥ andc
  156.                                           ELSE    28            ¥ and
  157.                                           THEN
  158.                                   THEN
  159.                               THEN
  160.  
  161.           [    otOr    ]=>        logicalType
  162.                               get: CR_op? 
  163.                               IF    19  get: complResult?
  164.                                   IF         33                    ¥ crnor
  165.                                   ELSE    get: complB?
  166.                                           IF        417            ¥ crorc
  167.                                           ELSE    449            ¥ cror
  168.                                           THEN
  169.                                   THEN
  170.                             ELSE
  171.                                   31    get: complResult?
  172.                                   IF        124                    ¥ nor
  173.                                   ELSE     get: complB?
  174.                                           IF        412            ¥ orc
  175.                                           ELSE    444            ¥ or
  176.                                           THEN
  177.                                   THEN
  178.                               THEN
  179.  
  180.           [    otXor    ]=>        logicalType
  181.                               get: CR_op? 
  182.                               IF    19  get: complResult?
  183.                                   IF         289                    ¥ creqv
  184.                                   ELSE    193                    ¥ crxor
  185.                                   THEN
  186.                             ELSE
  187.                                 31    get: complResult?
  188.                                   IF        284                    ¥ eqv
  189.                                   ELSE    316                    ¥ xor
  190.                                   THEN
  191.                               THEN
  192.  
  193.           [ otCMP    ]=>        cmpType         31  0
  194.           [    otUCMP    ]=>        cmpType            31    32
  195.           
  196.           [    otFPcmp    ]=>        cmpType            63    0
  197.                               subType 4 and
  198.                               IF        ¥ it's an FP comparison with zero - there's no special
  199.                                       ¥  instructions for this, so we keep zero in fpr14.
  200.                                   14 put: rB
  201.                               THEN
  202.  
  203. ¥          [ otFPcmpU ]=>    cmpType            63    32    ¥ if we implement unordered
  204.  
  205.           [    otTrap    ]=>        arithType        31    64bit? if 68 else 4 then
  206.                               subType  put: rD    ¥ this is actually the TO field
  207.  
  208.           [    otNEG    ]=>        arithType        31    104
  209.           
  210.           [    otNOT    ]=>        logicalType
  211.                               get: rA  put: rB            ¥ we do NOT with a nand
  212.                                                           ¥  or crnand, with rA = rB
  213.                                 get: CR_op?
  214.                                 IF
  215.                                 19    225                    ¥ crnand
  216.                               ELSE
  217.                                 31    476                    ¥ nand
  218.                               THEN
  219.  
  220.         DEFAULT=>        cr .h ."  undef op passed to setop" 1 die
  221.         
  222.     ]SELECT
  223.     put: secOp  put: primOp  dup put: inst_type
  224. ;m
  225.  
  226.  
  227. ¥ setLiteralOp does the same for literal operations.
  228.  
  229. :m SETLITERALOP:  { opType subtype -- inst_type }
  230.  
  231.     set: lit?  clear: shifted?
  232.     opType
  233.     SELECT[    otAdd    ]=>        arithType        14    
  234.                         ¥ subtract immed doesn't exist - we use add immed
  235.           [    otAddc    ]=>        arithType        12        ¥ addic
  236.           [ otSubfc ]=>        arithType        8        ¥ subfic
  237.           [    otMul    ]=>        arithType        7
  238.                         ¥ divide immed doesn't exist either!
  239.           [    otAnd    ]=>        logicalType        28
  240.           [    otOr    ]=>        logicalType        24
  241.           [    otXor    ]=>        logicalType        26
  242.           [ otCMP    ]=>        cmpType            11
  243.           [    otUCMP    ]=>        cmpType            10
  244.           [    otTrap    ]=>        arithType        64bit? if 2 else 3 then
  245.                               subType  put: rD    ¥ this is actually the TO field
  246.  
  247. ¥ otAdde and otSubfe can come here with a literal operand - only 0 and -1
  248. ¥  are legal (this should be OK as these only come from internal inline
  249. ¥  definitions).  We then generate addze, addme etc. as appropriate.
  250.  
  251.           [    otAdde    ]=>        get: lit  dup
  252.                               NIF  drop  202        ¥ addze
  253.                               ELSE    
  254.                                   -1 =
  255.                                   IF        234        ¥ addme
  256.                                   ELSE    ." otAdde with illegal lit " get: lit .
  257.                                           1 die
  258.                                   THEN
  259.                               THEN
  260.                               put: secop  clear: lit?
  261.                               arithType  31
  262.  
  263.           [    otSubfe    ]=>        get: lit  dup
  264.                               NIF    drop  200        ¥ subfze
  265.                               ELSE
  266.                                   -1 =
  267.                                   IF        232        ¥ subfme
  268.                                   ELSE    ." otSubfe with illegal lit " get: lit .
  269.                                           1 die
  270.                                   THEN
  271.                               THEN
  272.                               put: secop  clear: lit?
  273.                               arithType  31
  274.  
  275.  
  276.         DEFAULT=>        cr .h ."  undef op passed to setLiteralOp" 1 die
  277.         
  278.     ]SELECT
  279.     put: primOp  dup put: inst_type
  280. ;m
  281.  
  282.  
  283. :m PRINT:
  284.     ." type      "        print: inst_type    cr
  285.     ." primOp    "        print: primOp        cr
  286.     ." secOp     "        print: secOp        cr
  287.     get: inst_type  branchType =
  288.     IF    ." displ     "        print: lit            cr
  289.     ELSE
  290.         ." setCR?    "        print: setCR?        cr
  291.         ." rA        "        print: rA            cr
  292.         get: lit?
  293.         NIF    ." rB        "        print: rB        cr
  294.         THEN
  295.         ." rD        "        print: rD            cr
  296.         get: lit?
  297.         IF    ." lit  "
  298.             print: lit 4 spaces base hex  print: lit  -> base
  299.         THEN
  300.  
  301.         ." maskBegin    "        print: maskBegin    cr
  302.         ." maskEnd      "        print: maskEnd        cr
  303.         ." update?      "        print: update?        cr
  304.         ." complB?      "        print: complB?        cr
  305.         ." complResult? "        print: complResult?    cr
  306.         ." CR_op?       "        print: CR_op?        cr
  307.     THEN
  308. ;m
  309.  
  310. :m COMPILE:  { ¥ tmp branchOp updBit -- }
  311.  
  312. (* first we make the necessary adjustments depending on the instruction type.  For
  313.    the more unusual types we do the whole job then EXIT, while for the more normal
  314.    types we set things up then fall through to the generic compiling code.
  315. *)
  316.  
  317.     get: inst_type
  318.  
  319.     SELECT[    logicalType    ]=>
  320.     
  321.         (*    logical GPR instrns, for historical reasons, use the rA field
  322.             as the destination!   We just fix it here at the last moment
  323.             by swapping the rA and rD fields.
  324.         *)
  325.                         get: CR_op?
  326.                         NIF  get: rA  get: rD  put: rA  put: rD  THEN
  327.                         
  328.                         get: lit?  get: shifted? and  IF  get: primOp 1+  put: primOp  THEN
  329.                                 
  330.           [    arithType    ]=>
  331.         
  332.           [ cmpType        ]=>        get: rD  2 <<  put: rD        ¥ cr field#
  333.           
  334.           [    loadStoreType ]=>    false -> updBit
  335.                                   get: update?
  336.                                   IF    get: primOp 58 ( ld )  =
  337.                                       get: primOp 62 ( std ) = or
  338.                                       IF    1 +: lit
  339.                                       ELSE    ¥ assume lwz, stw, lfd or stfd
  340.                                           get: primOp 1+  put: primOp
  341.                                       THEN
  342.                                   THEN
  343.           
  344.           [    branchType    ]=>        get: primOp    26 <<    -> tmp
  345.                                   get: primOp 18 =    ¥ unconditional?
  346.                                   IF
  347.                                       get: lit  $ 03FFFFFF and  or> tmp
  348.                                   ELSE
  349.                                       get: use_cond? not $ 10 and     -> branchOp
  350.                                       get: use_CTR?  not 4 and    or> branchOp
  351.                                       get: use_cond?
  352.                                       IF    get: branchOn1? 8 and or> branchOp
  353.                                         get: rA        16 <<    or> tmp
  354.                                       THEN
  355.                                       branchOp  21 <<            or> tmp
  356.                                       get: lit  $ FFFF and    or> tmp
  357.                                   THEN
  358.                                   tmp code,        EXIT
  359.  
  360.           [    shiftType    ]=>    64bit?
  361.                               IF    db
  362.                               ELSE
  363.                                   get: primOp    26 <<    -> tmp
  364.                                   get: secOp
  365.                                   NIF        ¥ this must be a rotate and mask
  366.                                       get: maskBegin  6 <<    or> tmp
  367.                                       get: maskEnd    1 <<    or> tmp
  368.                                   ELSE
  369.                                       get: secOp  2*            or> tmp
  370.                                   THEN
  371.                           ¥ shifts have rA as the destination, like logicals
  372.                           ¥  - so our rA is really rS.
  373.                                   get: rA      21 <<            or> tmp
  374.                                   get: rD      16 <<            or> tmp
  375.                                   get: shift#    11 <<            or> tmp
  376.                                 get: setCR? 1 and            or> tmp
  377.                                   tmp code,    EXIT
  378.                             THEN
  379.  
  380.           DEFAULT=>                drop
  381.     ]SELECT
  382.  
  383.     get: primOp        26 <<    -> tmp
  384.     get: rA            16 <<    or> tmp
  385.     get: rD            21 <<    or> tmp
  386.  
  387.     get: lit?
  388.     IF
  389.         get: lit  $ FFFF and    or> tmp
  390.     ELSE
  391.         get: rB            11 <<    or> tmp
  392.         get: rC             6 <<    or> tmp
  393.         get: secOp        2*        or> tmp
  394.         
  395. ¥ finally we set Rc bit if necessary - note the only immediate instruction
  396. ¥  that sets CR0 is andi, which always does it, without using the Rc
  397. ¥  bit (which is part of the immediate field anyway).
  398.  
  399.         get: setCR? 1 and        or> tmp
  400.     THEN
  401.     
  402.     debug? if
  403.         cr ." compiling at "  CDP .h  cr
  404.         print: self  cr
  405.         ." instruction: "  tmp .h  cr
  406.     then
  407.  
  408.     tmp code,
  409. ;m
  410.  
  411. :m CLEAR:
  412.     ^base  ['] instruction_class ivarlen  erase
  413.     arithType put: inst_type
  414. (*
  415.     clear: rA  clear: rB  clear: rD
  416.     arithType put: inst_type
  417.     clear: primOp  clear: secOp  clear: lit
  418.     clear: setCR?  clear: lit?  clear: update?
  419.     clear: complB?  clear: complResult?  clear: CR_op?
  420.     clear: use_CTR?  clear: use_cond?  clear: branchOn1?
  421.     clear: kludgeShiftCnt?  clear: shifted?
  422. *)
  423. ;m
  424.  
  425. ;class
  426.  
  427.  
  428. instruction_class    INSTRN
  429. instruction_class    BRANCH_INSTRN
  430.     PPC? not [IF]  branchType >type: branch_instrn  [THEN]
  431.  
  432. 0    value    startCDP
  433. 0    value    deltaCDP
  434.  
  435.  
  436. forward  ALLOCATE_GPR
  437. forward  ALLOCATE_FPR
  438. forward  ALLOCATE_CR
  439.  
  440. forward  FREE_GPR
  441. forward  FREE_FPR
  442. forward  FREE_CR
  443.  
  444. forward  DEL_GPR
  445. forward  DEL_FPR
  446. forward  DEL_CR
  447.  
  448. forward  ?CLEAR_GPR
  449. forward  ?CLEAR_FPR
  450. forward  ?CLEAR_CR
  451.  
  452. forward  USE_GPR
  453. forward  USE_FPR
  454. forward  USE_CR
  455.  
  456. forward  SET_CR0
  457.  
  458. forward  GPR_CDP
  459. forward  FPR_CDP
  460. forward  CR_CDP
  461.  
  462. forward  REG_CHANGED
  463. forward  UPDATE_CDPs
  464. ¥ forward  UPDATE_opCDPs
  465. forward  FIX_CONTAINING_LOOP
  466.  
  467. forward  UPDATE_REFS
  468. forward  DEFER_STORE
  469. forward  HOIST_LATER
  470. ¥ forward  STORE_ALL_PENDING
  471.  
  472.  
  473. (*
  474. Class REFERENCE defines a reference to an OD (see below) or a short
  475. literal value (we try to handle these at compile time if possible).
  476. Our compile-time stack is an array of REFERENCEs.
  477.  
  478. Note: at the moment I'm just planning to track as much of the stack
  479. as will fit in the regs allocated for general operands.  I could allow
  480. more, but I'd need to keep a full OD for each stack cell rather than
  481. just a reg reference.  Also reg spills would be problematic, as would
  482. be making sure the OD in the reg list and the corresponding one in the
  483. stack always agreed.  I think the problems wouldn't be worth the trouble,
  484. especially as I don't think the number of valid stack cells that I can
  485. track will usually be very many, because of word calls requiring
  486. normalization of the stack.
  487. *)
  488.  
  489. ¥ Reference types:
  490.  
  491. enum { noRef gprRef fprRef crRef litRef pullRef }
  492.  
  493.  
  494. :class  REFERENCE  super{ object }
  495. record
  496. {
  497.     ubyte    REFTYPE
  498.   union
  499.     {    ubyte    REG#
  500.           var        LITVAL
  501. public
  502.         record
  503.           {    ubyte    FIELD#        ¥ note: same byte as REG#.  We rely on this!
  504.               ubyte    BIT#
  505.               bool    1_is_true?
  506.           }
  507. end_public
  508.       }
  509. }
  510.  
  511. :m PRINT:
  512.     get: refType
  513.     SELECT[    gprRef    ]=>        ."  gpr# "  print: reg#
  514.           [    fprRef    ]=>        ."  fpr# "  print: reg#
  515.           [ crRef    ]=>        ."  cr fld# " print: field#
  516.                               ."  bit# "        print: bit#
  517.                               ."  1_is_true? " print: 1_is_true?
  518.           [    litRef    ]=>        ."  lit  "
  519.                       print: litval 4 spaces base hex  print: litval  -> base
  520.  
  521.           [ pullRef    ]=>        ."  pull"
  522.             DEFAULT=>  drop    ."  noRef"
  523.     ]SELECT
  524.     cr
  525. ;m
  526.  
  527. :m REFTYPE:        get: refType  ;m
  528. :m >REFTYPE:    put: refType  ;m
  529.  
  530. :m GPR:        gprRef get: refType <>    IF cr .id: self cr
  531.                                         ." not a GPR ref" cr
  532.                                         print: self  1 die
  533.                                     THEN
  534.             get: reg#  ;m
  535.  
  536. :m FPR:        fprRef get: refType <>    IF    cr .id: self cr
  537.                                         ." not a FPR ref" cr
  538.                                         print: self  1 die
  539.                                     THEN
  540.             get: reg#  ;m
  541.             
  542. :m CR:        crRef get: refType <>    IF    cr .id: self cr
  543.                                         ." not a CR ref" cr
  544.                                         print: self  1 die
  545.                                     THEN
  546.             get: field#  ;m
  547.  
  548. :m REG:        inline{ get: reg#}  ;m
  549.  
  550. :m BIT#:    inline{ get: bit#}  ;m
  551.  
  552. :m 1_is_true?:    inline{ get: 1_is_true?}  ;m
  553.  
  554. :m LIT:        litRef get: refType <>    IF    .id: self cr
  555.                                         ." not a lit ref"  1 die
  556.                                     THEN
  557.             get: litval  ;m
  558.  
  559. :m CLEAR:
  560.     ^base  ['] reference ivarlen  erase  ;m
  561.  
  562. :m >REG:    inline{ put: reg#}  ;m
  563.     
  564. :m >GPR:    clear: self  gprRef put: refType  put: reg#        ;m
  565. :m >FPR:    clear: self  fprRef put: refType  put: reg#        ;m
  566. :m >CR:        clear: self  crRef  put: refType  put: field#    ;m
  567.  
  568. :m >CONDITION:  { opcode -- }
  569.     opcode 1 and      put: 1_is_true?
  570.     opcode 4 >>        put: bit#
  571. ;m
  572.  
  573. :m >LIT:    clear: self  litRef put: refType  put: litval  ;m
  574.  
  575. :m >PULL:    clear: self  pullRef  put: refType  ;m
  576.  
  577. :m ->:    ¥ ( ^ref -- )
  578.     ^base
  579.     ['] reference ivarlen    ¥ note length is 6 on 68k, but 8 on PPC
  580.                             ¥  due to alignment
  581.     aligned_move  ;m
  582.  
  583. ¥ Careful - the next 3 methods assume a reference is 6 bytes long!
  584.  
  585. :m =?:  { ^ref -- b }
  586.     false
  587. ¥    get: refType  noRef =  ?EXIT        ¥ "noRef" can't match, no matter what
  588.     ^ref ^base
  589.     ['] reference ivarlen
  590.     (s=)  0EXIT
  591.     drop  true
  592. ;m
  593.  
  594. :m STACK:    ¥ ( -- <ref-info> )
  595.     ^base @
  596.     ^base 4+ @
  597.     ^base 6 + w@  ;m
  598.  
  599. :m UNSTACK:    ¥ ( <ref-info> -- )
  600.     ^base 6 + w!
  601.     ^base 4+  !
  602.     ^base !  ;m
  603.  
  604.  
  605. :m MARK_USE:    ¥ ( CDPtoUse -- )  Marks the OD with a use at the given
  606.                 ¥  CDP position.
  607.     get: reg#
  608.     get: refType
  609.     SELECT[    gprRef    ]=>    use_gpr
  610.           [    fprRef    ]=>    use_fpr
  611.           [    crRef    ]=>    use_cr
  612.               DEFAULT=>        ( nothing to do )    2drop drop
  613.     ]SELECT
  614. ;m
  615.  
  616. :m ALLOCATE:    ¥ if this is a reg, allocates it.
  617.     get: refType
  618.     SELECT[ gprRef    ]=>        get: reg#  allocate_gpr
  619.           [ fprRef    ]=>        get: reg#  allocate_fpr
  620.           [ crRef    ]=>        get: reg#  allocate_cr
  621.               DEFAULT=>        ( nothing to do )    drop
  622.     ]SELECT
  623. ;m
  624.  
  625. :m FREE:        ¥ if this is a reg, frees it.
  626.     debug? if  ." freeing ref:" cr print: self  then
  627.     get: refType
  628.     SELECT[ gprRef    ]=>        get: reg# free_gpr
  629.           [ fprRef    ]=>        get: reg# free_fpr
  630.           [ crRef    ]=>        get: reg# free_cr
  631.               DEFAULT=>        ( nothing to do )  drop
  632.     ]SELECT
  633. ;m
  634.  
  635. :m DELETE:        ¥ if this is a reg, we delete it if safe to do so.
  636.                 ¥  Then whatever it was, we clear the ref.  We assume
  637.     debug? if  ." deleting ref:" cr print: self  then
  638.     get: refType
  639.     SELECT[ gprRef    ]=>        get: reg# del_gpr
  640.           [ fprRef    ]=>        get: reg# del_fpr
  641.           [ crRef    ]=>        get: reg# del_cr
  642.               DEFAULT=>        ( nothing to do )  drop
  643.     ]SELECT
  644.     clear: self
  645. ;m
  646.  
  647. :m opCDP:        ¥ if this is a reg, returns the CDP location of the associated
  648.                 ¥  operation, otherwise -1.
  649.     get: refType
  650.     SELECT[ gprRef    ]=>        get: reg#  gpr_CDP
  651.           [ fprRef    ]=>        get: reg#  fpr_CDP
  652.           [ crRef    ]=>        get: reg#  cr_CDP
  653.               DEFAULT=>        drop  -1
  654.     ]SELECT
  655. ;m
  656.  
  657. ;class
  658.  
  659.  
  660. reference    tmpRef1
  661. reference    tmpRef2
  662. reference    tmpRef3
  663. reference    tmpRef4
  664.  
  665.  
  666. :class  CSTACK_CLASS  super{ array }
  667.  
  668.     int    SIZE
  669.  
  670. :m PUSH:  ( n -- )
  671.     get: size  to: self  1 +: size
  672. ;m
  673.  
  674. :m POP:  ( -- n )
  675.     get: size 0<= IF  ." control stack underflow" 1 die  THEN
  676.     -1 +: size
  677.     get: size  at: self
  678. ;m
  679.  
  680. :m STK:  { cell# -- n }
  681.     get: size  cell# -  at: self  ;m
  682.  
  683. :m SIZE:    get: size  ;m
  684. :m >SIZE:    put: size  ;m
  685.  
  686. :m UPDATE:  { ¥ thisCDP -- }
  687.     get: size  0EXIT
  688.     get: size
  689.     FOR    i at: self  -> thisCDP
  690.         thisCDP startCDP u>=
  691.         IF  deltaCDP ++> thisCDP
  692.             thisCDP i to: self
  693.         THEN
  694.     NEXT
  695. ;m
  696.  
  697. :m MATCH?:  { n -- index T | -- F }
  698.     false
  699.     get: size  0
  700.     DO    i at: self  n =
  701.         IF    drop  i  true  LEAVE
  702.         THEN
  703.     LOOP
  704. ;m
  705.  
  706. :m PRINTALL:
  707.     ." depth: "  get: size .  cr
  708.     get: size
  709.     IF    get: size
  710.         FOR  ?pause  i at: self  .h cr  NEXT
  711.     THEN
  712. ;m
  713.  
  714. ;class
  715.  
  716.  
  717. ¥ see ppc3 for the definition of these flag bytes...
  718.  
  719. :class CSTACK_FLAGS_CLASS  super{ bArray }
  720.  
  721.     int    SIZE
  722.  
  723. :m SIZE:    get: size  ;m
  724. :m >SIZE:    put: size  ;m
  725.  
  726. :m PUSH:  ( n -- )
  727.     get: size  to: self  1 +: size
  728. ;m
  729.  
  730. :m POP:  ( -- n )
  731.     get: size 0<= IF  ." control stack flags underflow" 1 die  THEN
  732.     -1 +: size
  733.     get: size  at: self
  734. ;m
  735.  
  736. :m STK:  { cell# -- n }
  737.     get: size  cell# -  at: self  ;m
  738.  
  739. :m PRINTALL:
  740.     ." depth: "  get: size .  cr
  741.     get: size
  742.     IF    get: size
  743.         FOR  ?pause  i at: self  .h cr  NEXT
  744.     THEN
  745. ;m
  746.  
  747. ;class
  748.  
  749.  
  750. 128  cstack_class            CONTROL_STK
  751. 128     cstack_flags_class        CONTROL_FLAGS
  752.